perm filename ASCINT.F4[1,LCS] blob
sn#573308 filedate 1981-03-12 generic text, type T, neo UTF8
00100 SUBROUTINE ASCINT(I,RI,KNT,M)
00200 DIMENSION KNT(72),RI(72),I(72)
00300 INTEGER ZERO,NINE,KNT,J,I,DOT,BLA
00320 CC INTEGER*1 ZERO,NINE,KNT,J,I,DOT,BLA
00400 DATA DOT/'.'/,BLA/' '/,ZERO/'0'/,NINE/'9'/
01200 DO 10 K=1,72
01300 10 KNT(K)=-1
01400 IDEC=0
01500 M=1
01600 C=1.0
01700 R=0
01800 DO 5 K=1,72
01900 J=I(K)
02000 IF(J.EQ.BLA)GO TO 8
02100 IF(J.NE.DOT)GO TO 6
02200 IDEC=-1
02300 GO TO 5
02400 6 IF(J.GE.ZERO.AND.J.LE.NINE)GO TO 7
02500 CALL STOW(J,RI(M))
02600 KNT(M)=0
02800 GO TO 9
02900 7 IF(IDEC.NE.0)C=C*0.1
03000 CALL CONV(R,J)
03100 GO TO 5
03200 8 IF(R.EQ.0)GO TO 5
03300 A=R*C
03500 RI(M)=A
03600 KNT(M)=1
03700 R=0
03800 C=1.0
03850 IDEC=0
03900 9 M=M+1
04000 5 CONTINUE
04100 M=M-1
04700 END
04800
04900 SUBROUTINE CONV(R,J)
05000 CC INTEGER*1 J
05100 CC R=R*10.+J-48
05150 L=(J-'0')/536870912
05175 R=R*10.+L
05200 END
05300
05400 SUBROUTINE STOW(R,RI)
05500 RI=R
05600 END
05700
05800 SUBROUTINE ASC(R)
05900 200 FORMAT(' ',A1)
06000 WRITE(5,200)R
06100 END
06200 SUBROUTINE RNUM(R)
06300 201 FORMAT(F13.4)
06400 WRITE(5,201)R
06500 END